home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
lsp
/
defstruct.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-04
|
26KB
|
607 lines
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; DEFSTRUCT.LSP
;;;;
;;;; The structure routines.
(in-package 'lisp)
(export 'defstruct)
(in-package 'system)
(proclaim '(optimize (safety 2) (space 3)))
(defun make-access-function (name conc-name type named
slot-name default-init slot-type read-only
offset)
(declare (ignore named default-init slot-type))
(let ((access-function
(intern (si:string-concatenate (string conc-name)
(string slot-name)))))
(cond ((null type)
;; If TYPE is NIL,
;; the slot is at the offset in the structure-body,
;; which is just a list in this implementation.
(list* `(defun ,access-function (x)
(si:structure-ref x ',name ,offset))
`(si:putprop ',access-function ',(cons name offset)
'structure-access)
(if (not read-only)
;; The DEFSETF form is made only when READ-ONLY is NIL.
(list `(defsetf ,access-function (x) (v)
`(si:structure-set ,x ,'',name ,,offset ,v)))
(list `(remprop ',access-function 'setf-update-fn)
`(remprop ',access-function 'setf-lambda)
`(remprop ',access-function
'setf-documentation)))))
((or (eq type 'vector)
(and (consp type)
(eq (car type) 'vector)))
;; If TYPE is VECTOR or (VECTOR ... ), ELT is used.
(list* `(defun ,access-function (x) (elt x ,offset))
`(si:putprop ',access-function ',(cons 'vector offset)
'structure-access)
(if (not read-only)
(list `(defsetf ,access-function (x) (v)
`(si:elt-set ,x ,,offset ,v)))
;; Removing the DEFSETF definitions.
;; This code is implementation-dependent.
(list `(remprop ',access-function 'setf-update-fn)
`(remprop ',access-function 'setf-lambda)
`(remprop ',access-function
'setf-documentation)))))
((eq type 'list)
;; If TYPE is LIST, NTH is used.
(list* `(defun ,access-function (x) (si:list-nth ,offset x))
`(si:putprop ',access-function ',(cons 'list offset)
'structure-access)
(if (not read-only)
(list `(defsetf ,access-function (x) (v)
`(si:rplaca-nthcdr ,x ,,offset ,v)))
(list `(remprop ',access-function 'setf-update-fn)
`(remprop ',access-function 'setf-lambda)
`(remprop ',access-function
'setf-documentation)))))
((error "~S is an illegal structure type." type)))))
(defun make-constructor (name constructor type named
slot-descriptions)
(declare (ignore named))
(let ((slot-names
;; Collect the slot-names.
(mapcar #'(lambda (x)
(cond ((null x)
;; If the slot-description is NIL,
;; it is in the padding of initial-offset.
nil)
((null (car x))
;; If the slot name is NIL,
;; it is the structure name.
;; This is for typed structures with names.
(list 'quote (cadr x)))
(t (car x))))
slot-descriptions))
(keys
;; Make the keyword parameters.
(mapcan #'(lambda (x)
(cond ((null x) nil)
((null (car x)) nil)
((null (cadr x)) (list (car x)))
(t (list (list (car x) (cadr x))))))
slot-descriptions)))
(cond ((consp constructor)
;; The case for a BOA constructor.
;; Dirty code!!
;; We must add an initial value for an optional parameter,
;; if the default value is not specified
;; in the given parameter list and yet the initial value
;; is supplied in the slot description.
(do ((a (cadr constructor) (cdr a)) (l nil) (vs nil))
((endp a)
;; Add those options that do not appear in the parameter list
;; as auxiliary paramters.
;; The parameters are accumulated in the variable VS.
(setq keys
(nreconc (cons '&aux l)
(mapcan #'(lambda (k)
(if (member (if (atom k) k (car k))
vs)
nil
(list k)))
keys))))
;; Skip until &OPTIONAL appears.
(cond ((eq (car a) '&optional)
(setq l (cons '&optional l))
(do ((aa (cdr a) (cdr aa)) (ov) (y))
((endp aa)
;; Add those options that do not appear in the
;; parameter list.
(setq keys
(nreconc (cons '&aux l)
(mapcan #'(lambda (k)
(if (member (if (atom k)
k
(car k))
vs)
nil
(list k)))
keys)))
(return nil))
(when (member (car aa) lambda-list-keywords)
(when (eq (car aa) '&rest)
;; &REST is found.
(setq l (cons '&rest l))
(setq aa (cdr aa))
(unless (and (not (endp aa))
(symbolp (car aa)))
(illegal-boa))
(setq vs (cons (car aa) vs))
(setq l (cons (car aa) l))
(setq aa (cdr aa))
(when (endp aa)
(setq keys
(nreconc
(cons '&aux l)
(mapcan
#'(lambda (k)
(if (member (if (atom k)
k
(car k))
vs)
nil
(list k)))
keys)))
(return nil)))
;; &AUX should follow.
(unless (eq (car aa) '&aux)
(illegal-boa))
(setq l (cons '&aux l))
(do ((aaa (cdr aa) (cdr aaa)))
((endp aaa))
(setq l (cons (car aaa) l))
(cond ((and (atom (car aaa))
(symbolp (car aaa)))
(setq vs (cons (car aaa) vs)))
((and (symbolp (caar aaa))
(or (endp (cdar aaa))
(endp (cddar aaa))))
(setq vs (cons (caar aaa) vs)))
(t (illegal-boa))))
;; End of the parameter list.
(setq keys
(nreconc l
(mapcan
#'(lambda (k)
(if (member (if (atom k)
k
(car k))
vs)
nil
(list k)))
keys)))
(return nil))
;; Checks if the optional paramter without a default
;; value has a default value in the slot-description.
(if (and (cond ((atom (car aa)) (setq ov (car aa)) t)
((endp (cdar aa)) (setq ov (caar aa)) t)
(t nil))
(setq y (member ov
keys
:key
#'(lambda (x)
(if (consp x)
;; With default value.
(car x))))))
;; If no default value is supplied for
;; the optional parameter and yet appears
;; in KEYS with a default value,
;; then cons the pair to L,
(setq l (cons (car y) l))
;; otherwise cons just the parameter to L.
(setq l (cons (car aa) l)))
;; Checks the form of the optional parameter.
(cond ((atom (car aa))
(unless (symbolp (car aa))
(illegal-boa))
(setq vs (cons (car aa) vs)))
((not (symbolp (caar aa)))
(illegal-boa))
((or (endp (cdar aa)) (endp (cddar aa)))
(setq vs (cons (caar aa) vs)))
((not (symbolp (caddar aa)))
(illegal-boa))
((not (endp (cdddar aa)))
(illegal-boa))
(t
(setq vs (cons (caar aa) vs))
(setq vs (cons (caddar aa) vs)))))
;; RETURN from the outside DO.
(return nil))
(t
(unless (symbolp (car a))
(illegal-boa))
(setq l (cons (car a) l))
(setq vs (cons (car a) vs)))))
(setq constructor (car constructor)))
(t
;; If not a BOA constructor, just cons &KEY.
(setq keys (cons '&key keys))))
(cond ((null type)
`(defun ,constructor ,keys
(si:make-structure ',name ,@slot-names)))
((or (eq type 'vector)
(and (consp type) (eq (car type) 'vector)))
`(defun ,constructor ,keys
(vector ,@slot-names)))
((eq type 'list)
`(defun ,constructor ,keys
(list ,@slot-names)))
((error "~S is an illegal structure type" type)))))
(defun illegal-boa ()
(error "An illegal BOA constructor."))
(defun make-copier (name copier type named)
(declare (ignore named))
(cond ((null type)
`(defun ,copier (x)
(si:copy-structure x ',name)))
((or (eq type 'vector)
(and (consp type) (eq (car type) 'vector)))
`(defun ,copier (x) (copy-seq x)))
((eq type 'list)
`(defun ,copier (x) (copy-list x)))
((error "~S is an illegal structure type." type))))
(defun make-predicate (name predicate type named name-offset)
(cond ((null type)
;; If TYPE is NIL, the predicate searches the link
;; of structure-include, until there is no included structure.
`(defun ,predicate (x)
(and (si:structurep x)
(do ((n (si:structure-name x)))
((null n) nil)
(when (eq n ',name) (return t))
(setq n (get n 'structure-include))))))
((or (eq type 'vector)
(and (consp type) (eq (car type) 'vector)))
;; The name is at the NAME-OFFSET in the vector.
(unless named (error "The structure should be named."))
`(defun ,predicate (x)
(and (vectorp x)
(> (length x) ,name-offset)
(eq (elt x ,name-offset) ',name))))
((eq type 'list)
;; The name is at the NAME-OFFSET in the list.
(unless named (error "The structure should be named."))
(if (= name-offset 0)
`(defun ,predicate (x)
(and (consp x)
(eq (car x) ',name)))
`(defun ,predicate (x)
(do ((i ,name-offset (1- i))
(y x (cdr y)))
((= i 0) (and (consp y) (eq (car y) ',name)))
(unless (consp y) (return nil))))))
((error "~S is an illegal structure type."))))
;;; PARSE-SLOT-DESCRIPTION parses the given slot-description
;;; and returns a list of the form:
;;; (slot-name default-init slot-type read-only offset)
(defun parse-slot-description (slot-description offset)
(let (slot-name default-init slot-type read-only)
(cond ((atom slot-description)
(setq slot-name slot-description))
((endp (cdr slot-description))
(setq slot-name (car slot-description)))
(t
(setq slot-name (car slot-description))
(setq default-init (cadr slot-description))
(do ((os (cddr slot-description) (cddr os)) (o) (v))
((endp os))
(setq o (car os))
(when (endp (cdr os))
(error "~S is an illegal structure slot option."
os))
(setq v (cadr os))
(case o
(:type (setq slot-type v))
(:read-only (setq read-only v))
(t
(error "~S is an illegal structure slot option."
os))))))
(list slot-name default-init slot-type read-only offset)))
;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions
;;; with the new descriptions which are specified in the
;;; :include defstruct option.
(defun overwrite-slot-descriptions (news olds)
(if (null olds)
nil
(let ((sds (member (caar olds) news :key #'car)))
(cond (sds
(when (and (null (cadddr (car sds)))
(cadddr (car olds)))
;; If read-only is true in the old
;; and false in the new, signal an error.
(error "~S is an illegal include slot-description."
sds))
(cons (list (caar sds)
(cadar sds)
(caddar sds)
(cadddr (car sds))
;; The offset if from the old.
(car (cddddr (car olds))))
(overwrite-slot-descriptions news (cdr olds))))
(t
(cons (car olds)
(overwrite-slot-descriptions news (cdr olds))))))))
;;; The DEFSTRUCT macro.
(defmacro defstruct (name &rest slots)
(let ((slot-descriptions slots)
options
conc-name
constructors default-constructor no-constructor
copier
predicate predicate-specified
include
print-function type named initial-offset
offset name-offset
documentation)
(when (consp name)
;; The defstruct options are supplied.
(setq options (cdr name))
(setq name (car name)))
;; The default conc-name.
(setq conc-name (si:string-concatenate (string name) "-"))
;; The default constructor.
(setq default-constructor
(intern (si:string-concatenate "MAKE-" (string name))))
;; The default copier and predicate.
(setq copier
(intern (si:string-concatenate "COPY-" (string name)))
predicate
(intern (si:string-concatenate (string name) "-P")))
;; Parse the defstruct options.
(do ((os options (cdr os)) (o) (v))
((endp os))
(cond ((and (consp (car os)) (not (endp (cdar os))))
(setq o (caar os) v (cadar os))
(case o
(:conc-name
(if (null v)
(setq conc-name "")
(setq conc-name v)))
(:constructor
(if (null v)
(setq no-constructor t)
(if (endp (cddar os))
(setq constructors (cons v constructors))
(setq constructors (cons (cdar os) constructors)))))
(:copier (setq copier v))
(:predicate
(setq predicate v)
(setq predicate-specified t))
(:include
(setq include (cdar os))
(unless (get v 'is-a-structure)
(error "~S is an illegal included structure." v)))
(:print-function (setq print-function v))
(:type (setq type v))
(:initial-offset (setq initial-offset v))
(t (error "~S is an illegal defstruct option." o))))
(t
(if (consp (car os))
(setq o (caar os))
(setq o (car os)))
(case o
(:constructor
(setq constructors
(cons default-constructor constructors)))
((:conc-name :copier :predicate :print-function))
(:named (setq named t))
(t (error "~S is an illegal defstruct option." o))))))
;; Skip the documentation string.
(when (and (not (endp slot-descriptions))
(stringp (car slot-descriptions)))
(setq documentation (car slot-descriptions))
(setq slot-descriptions (cdr slot-descriptions)))
;; Check the include option.
(when include
(unless (equal type (get (car include) 'structure-type))
(error "~S is an illegal structure include."
(car include))))
;; Set OFFSET.
(cond ((null include)
(setq offset 0))
(t
(setq offset (get (car include) 'structure-offset))))
;; Increment OFFSET.
(when (and type initial-offset)
(setq offset (+ offset initial-offset)))
(when (and type named)
(setq name-offset offset)
(setq offset (1+ offset)))
;; Parse slot-descriptions, incrementing OFFSET for each one.
(do ((ds slot-descriptions (cdr ds))
(sds nil))
((endp ds)
(setq slot-descriptions (nreverse sds)))
(setq sds (cons (parse-slot-description (car ds) offset) sds))
(setq offset (1+ offset)))
;; If TYPE is non-NIL and structure is named,
;; add the slot for the structure-name to the slot-descriptions.
(when (and type named)
(setq slot-descriptions
(cons (list nil name) slot-descriptions)))
;; Pad the slot-descriptions with the initial-offset number of NILs.
(when (and type initial-offset)
(setq slot-descriptions
(append (make-list initial-offset) slot-descriptions)))
;; Append the slot-descriptions of the included structure.
;; The slot-descriptions in the include option are also counted.
(cond ((null include))
((endp (cdr include))
(setq slot-descriptions
(append (get (car include) 'structure-slot-descriptions)
slot-descriptions)))
(t
(setq slot-descriptions
(append (overwrite-slot-descriptions
(mapcar #'(lambda (sd)
(parse-slot-description sd 0))
(cdr include))
(get (car include)
'structure-slot-descriptions))
slot-descriptions))))
(cond (no-constructor
;; If a constructor option is NIL,
;; no constructor should have been specified.
(when constructors
(error "Contradictory constructor options.")))
((null constructors)
;; If no constructor is specified,
;; the default-constructor is made.
(setq constructors (list default-constructor))))
;; Check the named option and set the predicate.
(when (and type (not named))
(when predicate-specified
(error "~S is an illegal structure predicate."
predicate))
(setq predicate nil))
(when include (setq include (car include)))
;; Check the print-function.
(when (and print-function type)
(error "An print function is supplied to a typed structure."))
`(progn (si:putprop ',name
'(defstruct ,name ,@slots)
'defstruct-form)
(si:putprop ',name t 'is-a-structure)
(si:putprop ',name
',slot-descriptions
'structure-slot-descriptions)
(si:putprop ',name ',include 'structure-include)
(si:putprop ',name
',print-function
'structure-print-function)
(si:putprop ',name ',type 'structure-type)
(si:putprop ',name ',named 'structure-named)
,@(mapcan #'(lambda (x)
(if (and x (car x))
(apply #'make-access-function
name conc-name type named
x)))
slot-descriptions)
(si:putprop ',name ,offset 'structure-offset)
,@(mapcar #'(lambda (constructor)
(make-constructor name constructor type named
slot-descriptions))
constructors)
(si:putprop ',name ',constructors 'structure-constructors)
,@(if copier
(list (make-copier name copier type named)))
,@(if predicate
(list (make-predicate name predicate type named
name-offset)))
(si:putprop ',name ,documentation 'structure-documentation)
',name)))
;;; The #S reader.
(defun sharp-s-reader (stream subchar arg)
(declare (ignore subchar))
(when (and arg (null *read-suppress*))
(error "An extra argument was supplied for the #S readmacro."))
(let ((l (read stream)))
(unless (get (car l) 'is-a-structure)
(error "~S is not a structure." (car l)))
;; Intern keywords in the keyword package.
(do ((ll (cdr l) (cddr ll)))
((endp ll)
;; Find an appropriate construtor.
(do ((cs (get (car l) 'structure-constructors) (cdr cs)))
((endp cs)
(error "The structure ~S has no structure constructor."
(car l)))
(when (symbolp (car cs))
(return (apply (car cs) (cdr l))))))
(rplaca ll (intern (string (car ll)) 'keyword)))))
;; Set the dispatch macro.
(set-dispatch-macro-character #\# #\s 'sharp-s-reader)
(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
;; Examples from Common Lisp Reference Manual.
#|
(defstruct ship
x-position
y-position
x-velocity
y-velocity
mass)
(defstruct person name age sex)
(defstruct (astronaut (:include person (age 45))
(:conc-name astro-))
helmet-size
(favorite-beverage 'tang))
(defstruct (foo (:constructor create-foo (a
&optional b (c 'sea)
&rest d
&aux e (f 'eff))))
a (b 'bee) c d e f)
(defstruct (binop (:type list) :named (:initial-offset 2))
(operator '?)
operand-1
operand-2)
(defstruct (annotated-binop (:type list)
(:initial-offset 3)
(:include binop))
commutative
associative
identity)
|#